home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / OARITH.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  8.3 KB  |  435 lines
  1. /*
  2.  * File: oarith.r
  3.  *  Contents: arithmetic operators + - * / % ^.  Auxiliary routines
  4.  *   iipow, ripow.
  5.  *
  6.  * The arithmetic operators all follow a canonical conversion
  7.  * protocol encapsulated in the macro ArithOp.
  8.  */
  9.  
  10. int over_flow;
  11.  
  12. #begdef ArithOp(icon_op, func_name, c_int_op, c_real_op)
  13.  
  14.    operator{1} icon_op func_name(x, y)
  15.       declare {
  16. #ifdef LargeInts
  17.          tended struct descrip lx, ly;
  18. #endif                    /* LargeInts */
  19.      C_integer irslt;
  20.          }
  21.       if cnv:(exact)C_integer(x) && cnv:(exact)C_integer(y) then {
  22.          abstract {
  23.             return integer
  24.             }
  25.          inline {
  26.         extern int over_flow;
  27.             c_int_op(x,y);
  28.             }
  29.          }
  30. #ifdef LargeInts
  31.       else if cnv:(exact)integer(x,lx) && cnv:(exact)integer(y,ly) then {
  32.          abstract {
  33.             return integer
  34.             }
  35.          inline {
  36.             big_ ## c_int_op(lx,ly);
  37.             }
  38.          }
  39. #endif                        /* LargeInts */
  40.       else {
  41.          if !cnv:C_double(x) then
  42.             runerr(102, x)
  43.          if !cnv:C_double(y) then
  44.             runerr(102, y)
  45.          abstract {
  46.             return real
  47.             }
  48.          inline {
  49.             c_real_op(x, y);
  50.             }
  51.          }
  52. end
  53.  
  54. #enddef
  55.  
  56. /*
  57.  * x / y
  58.  */
  59.  
  60. #begdef big_Divide(x,y)
  61. {
  62.   bigdiv(&x,&y,&result);
  63.   return result;
  64. }
  65. #enddef
  66. #define Divide(x,y) return C_integer (x / y);
  67. #begdef RealDivide(x,y)
  68. {
  69.    double z;
  70. #ifdef ZERODIVIDE
  71.    if (y == 0.0)
  72.       runerr(204);
  73. #endif                        /* ZERODIVIDE */
  74.    z = x / y;
  75. #ifdef SUN
  76.    if (z == HUGE) {
  77.       kill(getpid(), SIGFPE);
  78.    }
  79. #endif
  80.    return C_double z;
  81. }
  82. #enddef
  83.  
  84.  
  85. ArithOp( / , divide , Divide , RealDivide )
  86.  
  87. /*
  88.  * x - y
  89.  */
  90.  
  91. #begdef big_Sub(x,y)
  92. {
  93.    if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */
  94.       runerr(0);
  95.    return result;
  96. }
  97. #enddef
  98.  
  99. #begdef Sub(x,y)
  100.    irslt = sub(x,y);
  101.    if (over_flow) {
  102. #ifdef LargeInts
  103.       MakeInt(x,&lx);
  104.       MakeInt(y,&ly);
  105.       if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */
  106.          runerr(0);
  107.       return result;
  108. #else                    /* LargeInts */
  109.       runerr(203);
  110. #endif                    /* LargeInts */
  111.       }
  112.    else return C_integer irslt;
  113. #enddef
  114.  
  115. #define RealSub(x,y) return C_double (x - y);
  116.  
  117. ArithOp( - , minus , Sub , RealSub )
  118.  
  119.  
  120. /*
  121.  * x % y
  122.  */
  123.  
  124. #define Abs(x) ((x) > 0 ? (x) : -(x))
  125. /*
  126.  * The sign of modulo's result must match that of x.
  127.  */
  128. #begdef MatchSignToX(x,y,theResult,zero)
  129.    if (x < zero) {
  130.       if (theResult > zero) {
  131.          theResult -= Abs(y);
  132.          }
  133.       }
  134.    else if (theResult < zero) {
  135.       theResult += Abs(y);
  136.       }
  137. #enddef
  138.  
  139. #begdef big_IntMod(x,y)
  140. {
  141.    if (bigmod(&x,&y,&result) == Error)
  142.       runerr(0);
  143.    return result;
  144. }
  145. #enddef
  146.  
  147. #begdef IntMod(x,y)
  148. {
  149.    if (y == 0) {
  150.       irunerr(202,y);
  151.       errorfail;
  152.       }
  153.    irslt = x % y;
  154.    MatchSignToX(x,y,irslt,0);
  155.    return C_integer irslt;
  156. }
  157. #enddef
  158.  
  159. #begdef RealMod(x,y)
  160. {
  161.    double d;
  162.    d = x - y * (int)(x / y);
  163.    MatchSignToX(x,y,d,0.0);
  164.    return C_double d;
  165. }
  166. #enddef
  167.  
  168. ArithOp( % , mod , IntMod , RealMod )
  169.  
  170. /*
  171.  * x * y
  172.  */
  173.  
  174. #begdef big_Mpy(x,y)
  175. {
  176.    if (bigmul(&x,&y,&result) == Error)
  177.       runerr(0);
  178.    return result;
  179. }
  180. #enddef
  181.  
  182. #begdef Mpy(x,y)
  183.    irslt = mul(x,y);
  184.    if (over_flow) {
  185. #ifdef LargeInts
  186.       MakeInt(x,&lx);
  187.       MakeInt(y,&ly);
  188.       if (bigmul(&lx,&ly,&result) == Error) /* alcbignum failed */
  189.          runerr(0);
  190.       return result;
  191. #else                    /* LargeInts */
  192.       runerr(203);
  193. #endif                    /* LargeInts */
  194.       }
  195.    else return C_integer irslt;
  196. #enddef
  197.  
  198.  
  199. #define RealMpy(x,y) return C_double (x * y);
  200.  
  201. ArithOp( * , mult , Mpy , RealMpy )
  202.  
  203.  
  204. "-x - negate x."
  205.  
  206. operator{1} - neg(x)
  207.    if cnv:(exact)C_integer(x) then {
  208.       abstract {
  209.          return integer
  210.          }
  211.       inline {
  212.         C_integer i;
  213.         extern int over_flow;
  214.  
  215.         i = neg(x);
  216.         if (over_flow) {
  217. #ifdef LargeInts
  218.            struct descrip tmp;
  219.            MakeInt(x,&tmp);
  220.            if (bigneg(&tmp, &result) == Error)  /* alcbignum failed */
  221.               runerr(0);
  222.                return result;
  223. #else                    /* LargeInts */
  224.            irunerr(203,x);
  225.                errorfail;
  226. #endif                    /* LargeInts */
  227.                }
  228.          return C_integer i;
  229.          }
  230.       }
  231. #ifdef LargeInts
  232.    else if cnv:(exact) integer(x) then {
  233.       abstract {
  234.          return integer
  235.          }
  236.       inline {
  237.      if (cpbignum(&x, &result) == Error)  /* alcbignum failed */
  238.         runerr(0);
  239.      BlkLoc(result)->bignumblk.sign ^= 1;
  240.      return result;
  241.          }
  242.       }
  243. #endif                    /* LargeInts */
  244.    else {
  245.       if !cnv:C_double(x) then
  246.          runerr(102, x)
  247.       abstract {
  248.          return real
  249.          }
  250.       inline {
  251.          double drslt;
  252.      drslt = -x;
  253.          return C_double drslt;
  254.          }
  255.       }
  256. end
  257.  
  258.  
  259. "+x - convert x to a number."
  260. /*
  261.  *  Operational definition: generate runerr if x is not numeric.
  262.  */
  263. operator{1} + number(x)
  264.    if cnv:(exact)C_integer(x) then {
  265.        abstract {
  266.           return integer
  267.           }
  268.        inline {
  269.           return C_integer x;
  270.           }
  271.       }
  272. #ifdef LargeInts
  273.    else if cnv:(exact) integer(x) then {
  274.        abstract {
  275.           return integer
  276.           }
  277.        inline {
  278.           return x;
  279.           }
  280.       }
  281. #endif                    /* LargeInts */
  282.    else if cnv:C_double(x) then {
  283.        abstract {
  284.           return real
  285.           }
  286.        inline {
  287.           return C_double x;
  288.           }
  289.       }
  290.    else
  291.       runerr(102, x)
  292. end
  293.  
  294. /*
  295.  * x + y
  296.  */
  297.  
  298. #begdef big_Add(x,y)
  299. {
  300.    if (bigadd(&x,&y,&result) == Error)
  301.       runerr(0);
  302.    return result;
  303. }
  304. #enddef
  305.  
  306. #begdef Add(x,y)
  307.    irslt = add(x,y);
  308.    if (over_flow) {
  309. #ifdef LargeInts
  310.       MakeInt(x,&lx);
  311.       MakeInt(y,&ly);
  312.       if (bigadd(&lx, &ly, &result) == Error)  /* alcbignum failed */
  313.      runerr(0);
  314.       return result;
  315. #else                    /* LargeInts */
  316.       runerr(203);
  317. #endif                    /* LargeInts */
  318.       }
  319.    else return C_integer irslt;
  320. #enddef
  321.  
  322. #define RealAdd(x,y) return C_double (x + y);
  323.  
  324. ArithOp( + , plus , Add , RealAdd )
  325.  
  326.  
  327. "x ^ y - raise x to the y power."
  328.  
  329. operator{1} ^ powr(x, y)
  330.    if cnv:(exact)integer(y) then {
  331.       if cnv:(exact)integer(x) then {
  332.          abstract {
  333.             return integer
  334.             }
  335.          inline {
  336.         extern int over_flow;
  337. #ifdef LargeInts
  338.             if (bigpow(&x, &y, &result) == Error)  /* alcbignum failed */
  339.                runerr(0);
  340.             return result;
  341. #else
  342.             C_integer r = iipow(IntVal(x), IntVal(y));
  343.             if (over_flow)
  344.                runerr(203);
  345.             return C_integer r;
  346. #endif
  347.            }
  348.          }
  349.       else {
  350.          if !cnv:C_double(x) then
  351.             runerr(102, x)
  352.          abstract {
  353.             return real
  354.             }
  355.          inline {
  356.             if (ripow(x,IntVal(y), &result) ==  Error)
  357.                 runerr(0);
  358.             return result;
  359.             }
  360.          }
  361.       }
  362.    else {
  363.       if !cnv:C_double(x) then
  364.          runerr(102, x)
  365.       if !cnv:C_double(y) then
  366.          runerr(102, y)
  367.       abstract {
  368.          return real
  369.          }
  370.       inline {
  371.          if (x == 0.0 && y < 0.0)
  372.              runerr(204);
  373.          if (x < 0.0)
  374.             runerr(206);
  375.          return C_double pow(x,y);
  376.          }
  377.       }
  378. end
  379.  
  380. #if COMPILER || !(defined LargeInts)
  381. /*
  382.  * iipow - raise an integer to an integral power. 
  383.  */
  384. C_integer iipow(n1, n2)
  385. C_integer n1, n2;
  386.    {
  387.    C_integer result;
  388.  
  389.    if (n1 == 0 && n2 <= 0) {
  390.       over_flow = 1;
  391.       return 0;
  392.       }
  393.    if (n2 < 0)
  394.       return 0;
  395.    result = 1L;
  396.    while (n2 > 0) {
  397.       if (n2 & 01L)
  398.          result *= n1;
  399.       n1 *= n1;
  400.       n2 >>= 1;
  401.       }
  402.    over_flow = 0;
  403.    return result;
  404.    }
  405. #endif                    /* COMPILER || !(defined LargeInts) */
  406.  
  407.  
  408. /*
  409.  * ripow - raise a real number to an integral power.
  410.  */
  411. int ripow(r, n, drslt)
  412. double r;
  413. C_integer n;
  414. dptr drslt;
  415.    {
  416.    double retval;
  417.  
  418.    if (r == 0.0 && n <= 0) 
  419.       ReturnErrNum(204, Error);
  420.    if (n < 0) {
  421.       n = -n;
  422.       r = 1.0 / r;
  423.       }
  424.    retval = 1.0;
  425.    while (n > 0) {
  426.       if (n & 01L)
  427.          retval *= r;
  428.       r *= r;
  429.       n >>= 1;
  430.       }
  431.    Protect(BlkLoc(*drslt) = (union block *)alcreal(retval), return Error);
  432.    drslt->dword = D_Real;
  433.    return Succeeded;
  434.    }
  435.